perm filename NOTBMS.F4[NEW,LCS]19 blob
sn#433848 filedate 1979-04-15 generic text, type T, neo UTF8
00100 C***** SUBRS NOTES, MISMCH ***********
00200
00300 SUBROUTINE NOTES
00400 COMMON/SCM/V(78),I,LCNT,STAFF,LIST(200),REND
00500 1 /SCX/JALPHA(30),JX,RA,JZ,IRHY,RB,KA,KB,IZ
00600 1 /XRN/RN(1)
00700 1 /SC/J,L,MK,ISKP,XMINUS,N,IEXP,LK,NNUM,JJ,JA,DBST,NFLG,
00800 1 JXX,ISEMI,IQT,VX(50),IAMP,K,KN,M,MODE,IBLA /ALF/CLF,JQX,D,
00900 1 KQ,JG,X,ACC,STMDR,Y,LL,RZ,RC,INP(61) /POS/POS1,POS2,PSFB
01000 1 /FRMT/F78F(1),FA1(1),FA5(1),ASK
01100 1 /RINP/R(10,85),RPOS(2,50) /RMOD/RMODE2,SET4,IBEAM,
01200 1 NOSET,STEM,STUP,NTC,PS2,RAM,JSTEM,ITB,POSB
01300 CX 1 NOSET,STEM,STUP,NTC,PS2,RAM,RDD,ITB,POSB
01400 CCC DATA ACMV/2.3/
01500 RMODE=0
01600 JSTEM=1000
01700 C JSTEM IS FOR BEAMS ROUTINE.
01800 IF(RMODE2.GE.500)RMODE=RMODE2
01900 C RMODE2≥500 IS FOR USER-ADDED NOTE AND REST ROUTINE (SUBR EXTRA)
02000 CP POS1=0
02100 CP POS2=200
02200 STFLG=0
02300 8 KN=0
02400 IRHY=0
02500 C IZ=# OF ITEMS FROM SCANR*******
02600 IZ=I-1
02700 C LIMIT OF 100 ITEMS***** 4/74 *****
02800 CLF=0
02900 KCLF=0
03000 JCLF=0
03100 C DEFAULT IS ALWAYS TREBLE CLEF
03200
03300 IF(POS2.NE.0)GO TO 71
03400 POS2=200
03500 71 K=IZ+1
03600 DO 70 KQ=1,IZ
03700 X=V(KQ)
03800 IF(X.GE.0)GO TO 70
03900 IF(-X.LT.2000)K=K-1
04000 C TO GET THE RIGHT ITEM COUNT WITH CHORDS, ETC.
04100 70 CONTINUE
04200
04300 D=(POS2-POS1)/K
04400 C D WILL SPACE ALL ITEMS EVENLY FOR NOW
04500
04600 STEM=-1
04700 C K=COUNTER FOR USEFUL ITEMS (OMITS CLEFS)
04800 K=1
04900 KQ=1
05000 C LOOPS TO 7333
05100 7 JG=-1
05200 X=V(KQ)
05300 C notes = 1xyz.0 x=accidental, yz=note num., negative=chord note
05400 C rest = 2xyz.0 z=0=ordinary, =1=invis., =2=whole, =3=repeat bar
05500 C =4=down, =5=up, -2xyz=num. of meas. rest
05600 C clefs = 3xyz.0 z=0=treble, =1=bass, =2=alto, =3=tenor, neg.=invis.
05700 C bars = 4xyz.0 z=num. of staves up, neg.=dbl.bar
05800 C ksig = 17xyz.0 z=num. of accis., pos.=#, neg.=b
05900 C meter = 18xyz.n xy=top num, zn=bottom num (DONE IN SCMSS)
06000 C stem = 5xyz.0 YZ=10=stem up, =20=stem down
06100 C staff = 5xyz.0 z=0=return to norm., =1=lower stf., =2=upper stf.
06200
06300 IF(X)GO TO 27
06400 C NEXT SORTS OUT ORDER OF CHORD
06500 RZ=V(KQ+1)
06600 IF(RZ.GT.0)GO TO 27
06700 IF(ABS(RZ).GE.2000)GO TO 27
06800 C SKIPS NON-NOTES
06900 327 RZ=AMOD(X,100.0)
07000 57 LL=KQ
07100 Y=0
07200 RA=RZ
07300 37 LL=LL+1
07400 STMDR=RA
07500 RA=-V(LL)
07600 IF(RA)GO TO 27
07700 IF(RA.GE.4000)GO TO 27
07800 C EXITS WITH NON-NOTES OR NON-CHORD NOTES. (ABOVE FOR DBL BAR)
07900 RA=AMOD(RA,100.0)
08000 C GETS RID OF ACCI. FOR NOW
08100 IF(RA.GE.99)GO TO 27
08200 IF(Y)127,97,67
08300 C Y IS STEM DIRECTION. -1=DOWN, 1=UP
08400 97 Y=RA-STMDR
08500 GO TO 37
08600 67 IF(RA.LT.RZ)V(LL)=V(LL)-7
08700 C TRAP FOR NOTE IN WRONG OCT. (CONFUSES STEM DIRECTION.)
08800 IF(RA.GE.STMDR)GO TO 37
08900 227 CALL EXCH(V(LL),V(LL-1))
09000 C NOW START OVER AGAIN
09100 GO TO 57
09200 127 IF(RA.GT.RZ)V(LL)=V(LL)+7
09300 IF(STMDR.GT.RA)GO TO 37
09400 GO TO 227
09500 27 R4=0
09600 R5=0
09700 R6=0
09800 R8=0
09900 DO 89 LL=2,10
10000 89 R(LL,K)=0
10100 C TO CLEAR END OF ITEM
10200 KODE=ABS(X)/1000
10300 IF(X.LT.0.AND.KODE.NE.2)GO TO 86
10400 C JUMP IF A CHORD NOTE, CLEF OR BAR OR METER
10500 IF(KODE.LE.2)IRHY=IRHY+1
10600 C ADDS A RHYTHMIC UNIT
10700 C TO CLEAR LAST PARAMS IN SOME ITEMS LATER
10800 86 GO TO (21,22,23,24,25),KODE
10900 IF(KODE.EQ.17)GO TO 1700
11000 C NEXT IS FOR METERS
11100 L=(X-18000.)/10
11200 R5=L
11300 C GETS TOP NUM OF METER
11400 R6=AMOD(X,10.0)*10.0+.01
11500 GO TO 843
11600
11700 23 CLF=ABS(X)-3000.
11800 JCLF=CLF
11900 IF(X)GO TO 871
12000 C IS THE CLEF INVISIBLE?
12100 R5=CLF
12200 IF(K.EQ.1)GO TO 123
12300 IF(KCLF.OR.R(1,K-1).NE.4)R4=R4+100
12400 C IF NOT 1ST ITEM (AND 1ST IS NOT BAR) THEN MINI CLEF.
12500 123 KCLF=-1
12600 GO TO 843
12700
12800 25 Y=X-5000
12900 IF(Y.LT.10)GO TO 250
13000 C NEXT FOR STEM UP, DOWN
13100 C DOWN = 20 (5020), UP=10 (5010)
13200 STEM=Y
13300 IF(JSTEM.EQ.1000)JSTEM=K
13400 C SAVE POINTER TO FIRST SPECIFIED STEM DIRECTION. (FOR BEAMS)
13500 GO TO 871
13600 250 STFLG=Y
13700 C STAFF ABOVE=2, BELOW=1, RESET=0
13800 GO TO 871
13900
14000 24 R4=ABS(X)-4000
14100 CALL NOZERO(R4)
14200 IF(X)R4=R4+1000
14300 C NEG =DBL BAR.
14400 GO TO 843
14500
14600 1700 R5=ABS(X)-17000.
14700 C KEY SIGS NEG=FLATS
14800 IF(X)R5=-R5
14900 R6=CLF
15000 GO TO 843
15100
15200 22 Y=ABS(X)-2000
15300 IF(X)GO TO 831
15400 IF(Y.EQ.0)GO TO 843
15500 C ORDINARY REST=0
15600 IF(Y.LT.4)GO TO 882
15700 C REST UP=5, DOWN=4
15800 R4=6
15900 IF(Y.EQ.4)R4=-R4
16000 GO TO 843
16100
16200 882 IF(Y.EQ.1)GO TO 885
16300 IF(Y.EQ.2)GO TO 886
16400 C NEXT FOR CENTERED REPEAT SIGN
16500 R8=-5
16600 GO TO 843
16700
16800 885 R6=-2
16900 C ↑↑ FOR INVIS. REST (FIRST YOU SEE IT, THEN YOU DON'T.)
17000 GO TO 843
17100
17200 886 R8=-1
17300 C ↑ FOR WHOLE REST (ANY RHYTHM)
17400 GO TO 843
17500
17600 831 R8=Y
17700 C NUMS OF BARS REST
17800 GO TO 843
17900
18000 21 R(10,K)=STFLG
18100 IF(X.GT.0)GO TO 210
18200 X=-X
18300 R8=-1
18400 C CHORD NOTE
18500 JG=0
18600 210 LL=X-1000
18700 C NOTES
18800 L=LL/100
18900 C THE ACCI.
19000 R5=L
19100 N=MOD(LL,100)-1
19200 C THE NOTE NUM.
19300 L=N/7
19400 C OCT. NUM HERE IS 1 .GT. THAN THAT TYPED. (OCT. 0 IS POSSIBLE NOW.)
19500 N=MOD(N,7)+1
19600 C ABSOLUTE NOTE NUM.
19700 KA=JCLF*12
19800 C THIS WILL ADJUST FOR CLEF NUM.
19900 IF(JCLF.GE.2)KA=JCLF*2+2
20000 R4=(L-4)*7+KA+N
20100 STMDR=10.
20200 IF(R4.GE.7)STMDR=20.
20300 IF(STEM.LE.0)GO TO 26
20400 STMDR=STEM
20500 C SHORTEN STEMS WHEN TURNED TO NON-STANDARD DIRECTION.
20600 CCC NO NO NO -- THIS USED ELSEWHERE. R8=-1
20700 C FOR STEM DIRECTIONS - 'B' AND HIGHER HAVE STEMS DOWN.
20800 26 IF(JG.GE.0)GO TO 6
20900 C NEXT LENGTHENS STEMS FOR VERY HIGH OR VERY LOW NOTES.
21000 IF(STMDR.EQ.20)GO TO 16
21100 C NEXT FOR STEM UP
21200 IF(R4.LT.0)R8=-R4
21300 C STEMS OF VERY HIGH OR VERY LOW NOTES WILL ALWAYS TOUCH MIDDLE LINE
21400 GO TO 3133
21500 16 IF(R4.GT.14)R8=R4-14
21600 C SEE 'BEAMS' AT 143 FOR SIMILAR FEATURE
21700 GO TO 3133
21800 6 L=K-1
21900 IF(R(5,L).GE.10.)MX=L
22000 C MX=1ST NOTE OF CHRD
22100 STMDR=0
22200 L=K-MX
22300 IF(R4.LT.R(4,MX))L=-L
22400 R(7,MX)=L
22500 C L+=STEM UP, L-=STEM DOWN ... USED AT END OF NOTES.
22600 X=ABS(R(4,MX)-R4)-1.
22700 C EXTENDS THE STEM!
22800 C AFTER 1ST NOTE, ORDER MAY BE SCRAMBLED IN CHORDS. STEM OK.
22900 IF(X.LT.1.)X=1.
23000 IF(R(8,MX).LT.X)R(8,MX)=X
23100 3133 R5=R5+STMDR
23200
23300 843 R(4,K)=R4
23400 R(5,K)=R5
23500 R(6,K)=R6
23600 R(8,K)=R8
23700 CS R(2,K)=STAFF
23800 IF(JG)KN=KN+1
23900 R(3,K)=KN*D+POS1
24000 R(1,K)=KODE
24100 87 K=K+1
24200 871 KQ=KQ+1
24300 IF(KQ.LE.IZ)GO TO 7
24400
24500 IZ=K-1
24600 C IZ IS NOW REALLY THE NUMBER OF ITEMS TO BE PROCESSED
24700 C NEXT ADJUSTS PLACEMENT OF ACCIDENTALS AND 2NDS.
24800 K=1
24900 1 RX=R(7,K)
25000 IF(RX.EQ.0)GO TO 2
25100 IF(R(1,K).EQ.2.)GO TO 2
25200 C JUMP IF NO CHRD COMING
25300 IF(RX.GT.0)GO TO 3
25400 C JUMP IF STEM IS UP
25500 RA=R(5,K)
25600 IF(RA.LT.10)GO TO 277
25700 IF(RA.LT.20.)R(5,K)=RA+10.
25800 C PUTS STEM DOWN IF IT WASN'T
25900 277 L=K-RX
26000 C RX=TOTAL(-1) NOTES IN CHORD
26100 R(7,K)=0
26200 4 RA=R(4,K)
26300 RC=0
26400 C INTERVAL TO PREVIOUS NOTE
26500 C CHECK ON USE OF N ELSEWHERE
26600 N=K+1
26700 IF(K.LT.L)RC=RA-R(4,N)
26800 C INTERVAL TO NEXT NOTE
26900 IF(RC+R(6,K).EQ.1.)R(6,N)=20
27000 C PUSHES NOTE TO LEFT
27100 5 K=N
27200 IF(K.GT.L)GO TO 220
27300 GO TO 4
27400
27500 3 DO 30 M=2,IZ
27600 L=M-1
27700 IF(R(4,M)-R(4,L)+R(6,L).NE.1.)GO TO 30
27800 IF(R(3,M).NE.R(3,L))GO TO 30
27900 R(6,M)=10
28000 R(6,L)=30
28100 30 CONTINUE
28200 C TO HELP DOTTED NOTES.
28300 C MOVES NOTE TO RIGHT OF STEM WHEN 2ND.
28400 C THE STEM IS UP
28500 RA=R(5,K)
28600 IF(RA.GE.20.)R(5,K)=RA-10.
28700 C PUTS STEM UP IF IT WASN'T
28800 R(7,K)=0
28900 K=1+K+RX
29000 220 CALL ACSHFT(RX)
29100 C L=K-1=END OF CHORD; L-ABS(RX)=START OF CHORD; +RX=↑ -RX=↓
29200 GO TO 222
29300
29400 2 K=K+1
29500 222 IF(K.LE.IZ)GO TO 1
29600 R(1,K)=0
29700 END
29800
29900
30000
30100 SUBROUTINE MISMCH(RA,Y)
30200 CALL TYPCRLF
30300 CALL TYPSTR('**** MISMATCH WITH SPACING STAFF ****')
30400 CALL TYPFLT(RA)
30500 CALL TYPCRLF
30600 CALL TYPFLT(Y)
30700 CALL TYPSTR(' QUARTERS IN THIS LINE.')
30800 CALL TYPCRLF
30900 END